home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / UNIXTOOL / GNU / TILEFORTH / TILE / TILE~ / !Tile / test / mappings < prev    next >
Text File  |  1992-04-19  |  2KB  |  80 lines
  1. .( Loading Mappings test...) cr
  2.  
  3. #include <tile$lib>.mappings
  4. #include <tile$lib>.blocks
  5.  
  6. blocks mappings
  7.  
  8. .( 1: Create symbols that always return pointers to their entry) cr
  9.  
  10. : item ( -- )
  11.   create last ,
  12. does> ( addr -- item)
  13.   @
  14. ;
  15. cr
  16.  
  17. .( 2: Define some common colors) cr
  18.  
  19. item white ( -- item)
  20. item black ( -- item)
  21. item yellow ( -- item)
  22. item red ( -- item)
  23. item green ( -- item)
  24. item blue ( -- item)
  25. item brown ( -- item)
  26. item black ( -- item)
  27. cr
  28.  
  29. .( 3: Create a color-value mapping; item x integer) cr
  30.  
  31. 10 mapping COLOR-VALUE ( -- mapping)
  32. COLOR-VALUE ?empty-mapping . COLOR-VALUE size-mapping . COLOR-VALUE .mapping cr
  33. cr
  34.  
  35. .( 4: Add some mapping pairs; domain x range) cr
  36.  
  37. 255 white COLOR-VALUE add-mapping
  38. COLOR-VALUE ?empty-mapping . COLOR-VALUE size-mapping . COLOR-VALUE .mapping cr
  39.  
  40. 0 black COLOR-VALUE add-mapping
  41. COLOR-VALUE ?empty-mapping . COLOR-VALUE size-mapping . COLOR-VALUE .mapping cr
  42. cr
  43.  
  44. .( 5: Check if range values are available) cr
  45.  
  46. red COLOR-VALUE ?range-mapping . 
  47. white COLOR-VALUE ?range-mapping .
  48. black COLOR-VALUE ?range-mapping . cr
  49. cr
  50.  
  51. .( 6: Fetch range value and display) cr
  52. red COLOR-VALUE range-mapping .
  53. white COLOR-VALUE range-mapping @ .
  54. black COLOR-VALUE range-mapping @ . cr 
  55. cr
  56.  
  57. .( 7: Increment the black range value) cr
  58.  
  59. 1 black COLOR-VALUE range-mapping +! 
  60. COLOR-VALUE ?empty-mapping . COLOR-VALUE size-mapping . COLOR-VALUE .mapping cr
  61. cr
  62.  
  63.  
  64. .( 8: Add a red color mapping and remove successive pairs) cr
  65.  
  66. 127 red COLOR-VALUE add-mapping
  67. COLOR-VALUE ?empty-mapping . COLOR-VALUE size-mapping . COLOR-VALUE .mapping cr
  68.  
  69. red COLOR-VALUE remove-mapping
  70. COLOR-VALUE ?empty-mapping . COLOR-VALUE size-mapping . COLOR-VALUE .mapping cr
  71.  
  72. white COLOR-VALUE remove-mapping
  73. COLOR-VALUE ?empty-mapping . COLOR-VALUE size-mapping . COLOR-VALUE .mapping cr
  74.  
  75. black COLOR-VALUE remove-mapping
  76. COLOR-VALUE ?empty-mapping . COLOR-VALUE size-mapping . COLOR-VALUE .mapping cr
  77. cr
  78.  
  79. forth only
  80.